home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 11 / CU Amiga Magazine's Super CD-ROM 11 (1997)(EMAP Images)(GB)(Track 1 of 3)[!][issue 1997-06].iso / cucd / programming / oberonv4 / source / system / opb.mod (.txt) < prev    next >
Oberon Text  |  1996-06-09  |  56KB  |  1,497 lines
  1. Syntax20b.Scn.Fnt
  2. ParcElems
  3. Alloc
  4. Syntax24b.Scn.Fnt
  5. Syntax10.Scn.Fnt
  6. Syntax24.Scn.Fnt
  7. (* AMIGA *)
  8. (* Notify Ralf for maintenance of Non-FPU source *)
  9. (* added SYSTEM.CALL    OJ *)
  10. MODULE OPB;    (* RC 6.3.89 / 21.2.94 *)
  11. (* build parse tree *)
  12.     IMPORT OPT, OPS, OPM;
  13.     CONST
  14.         (* symbol values or ops *)
  15.         times = 1; slash = 2; div = 3; mod = 4;
  16.         and = 5; plus = 6; minus = 7; or = 8; eql = 9;
  17.         neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
  18.         in = 15; is = 16; ash = 17; msk = 18; len = 19;
  19.         conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
  20.         (*SYSTEM*)
  21.         adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
  22.         (* object modes *)
  23.         Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
  24.         SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
  25.         (* Structure forms *)
  26.         Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  27.         Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  28.         Pointer = 13; ProcTyp = 14; Comp = 15;
  29.         intSet = {SInt..LInt}; realSet = {Real, LReal};
  30.         (* composite structure forms *)
  31.         Basic = 1; Array = 2; DynArr = 3; Record = 4;
  32.         (* nodes classes *)
  33.         Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
  34.         Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
  35.         Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
  36.         Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
  37.         Nreturn = 26; Nwith = 27; Ntrap = 28;
  38.         (*function number*)
  39.         assign = 0;
  40.         haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
  41.         entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
  42.         shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
  43.         inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
  44.         (*SYSTEM function number*)
  45.         adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
  46.         getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
  47.         bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; callfn = 33;        (*<<OJ*)
  48.         (* module visibility of objects *)
  49.         internal = 0; external = 1; externalR = 2;
  50.         (* procedure flags (conval^.setval) *)
  51.         hasBody = 1; isRedef = 2; slNeeded = 3;
  52.         AssertTrap = 0;    (* default trap number *)
  53.         typSize*: PROCEDURE(typ: OPT.Struct; allocDesc: BOOLEAN);
  54.         exp: INTEGER;    (*side effect of log*)
  55.         maxExp: LONGINT;    (* max n in ASH(1, n) on this machine *)
  56.     PROCEDURE err(n: INTEGER);
  57.     BEGIN OPM.err(n)
  58.     END err;
  59.     PROCEDURE NewLeaf*(obj: OPT.Object): OPT.Node;
  60.         VAR node: OPT.Node;
  61.     BEGIN
  62.         CASE obj^.mode OF
  63.           Var:
  64.                 node := OPT.NewNode(Nvar); node^.readonly := (obj^.vis = externalR) & (obj^.mnolev < 0)
  65.         | VarPar:
  66.                 node := OPT.NewNode(Nvarpar)
  67.         | Con:
  68.                 node := OPT.NewNode(Nconst); node^.conval := OPT.NewConst();
  69.                 node^.conval^ := obj^.conval^    (* string is not copied, only its ref *)
  70.         | Typ:
  71.                 node := OPT.NewNode(Ntype)
  72.         | LProc..IProc:
  73.                 node := OPT.NewNode(Nproc)
  74.         ELSE err(127); node := OPT.NewNode(Nvar)
  75.         END ;
  76.         node^.obj := obj; node^.typ := obj^.typ;
  77.         RETURN node
  78.     END NewLeaf;
  79.     PROCEDURE Construct*(class: SHORTINT; VAR x: OPT.Node;  y: OPT.Node);
  80.         VAR node: OPT.Node;
  81.     BEGIN
  82.         node := OPT.NewNode(class); node^.typ := OPT.notyp;
  83.         node^.left := x; node^.right := y; x := node
  84.     END Construct;
  85.     PROCEDURE Link*(VAR x, last: OPT.Node; y: OPT.Node);
  86.     BEGIN
  87.         IF x = NIL THEN x := y ELSE last^.link := y END ;
  88.         WHILE y^.link # NIL DO y := y^.link END ;
  89.         last := y
  90.     END Link;
  91.     PROCEDURE BoolToInt(b: BOOLEAN): LONGINT;
  92.     BEGIN
  93.         IF b THEN RETURN 1 ELSE RETURN 0 END
  94.     END BoolToInt;
  95.     PROCEDURE IntToBool(i: LONGINT): BOOLEAN;
  96.     BEGIN
  97.         IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
  98.     END IntToBool;
  99.     PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node;
  100.         VAR x: OPT.Node;
  101.     BEGIN
  102.         x := OPT.NewNode(Nconst); x^.typ := OPT.booltyp;
  103.         x^.conval := OPT.NewConst(); x^.conval^.intval := BoolToInt(boolval); RETURN x
  104.     END NewBoolConst;
  105.     PROCEDURE OptIf*(VAR x: OPT.Node);    (* x^.link = NIL *)
  106.         VAR if, pred: OPT.Node;
  107.     BEGIN
  108.         if := x^.left;
  109.         WHILE if^.left^.class = Nconst DO
  110.             IF IntToBool(if^.left^.conval^.intval) THEN x := if^.right; RETURN
  111.             ELSIF if^.link = NIL THEN x := x^.right; RETURN
  112.             ELSE if := if^.link; x^.left := if
  113.             END
  114.         END ;
  115.         pred := if; if := if^.link;
  116.         WHILE if # NIL DO
  117.             IF if^.left^.class = Nconst THEN
  118.                 IF IntToBool(if^.left^.conval^.intval) THEN
  119.                     pred^.link := NIL; x^.right := if^.right; RETURN
  120.                 ELSE if := if^.link; pred^.link := if
  121.                 END
  122.             ELSE pred := if; if := if^.link
  123.             END
  124.         END
  125.     END OptIf;
  126.     PROCEDURE Nil*(): OPT.Node;
  127.         VAR x: OPT.Node;
  128.     BEGIN
  129.         x := OPT.NewNode(Nconst); x^.typ := OPT.niltyp;
  130.         x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.nilval; RETURN x
  131.     END Nil;
  132.     PROCEDURE EmptySet*(): OPT.Node;
  133.         VAR x: OPT.Node;
  134.     BEGIN
  135.         x := OPT.NewNode(Nconst); x^.typ := OPT.settyp;
  136.         x^.conval := OPT.NewConst(); x^.conval^.setval := {}; RETURN x
  137.     END EmptySet;
  138.     PROCEDURE SetIntType(node: OPT.Node);
  139.         VAR v: LONGINT;
  140.     BEGIN v := node^.conval^.intval;
  141.         IF (OPM.MinSInt <= v) & (v <= OPM.MaxSInt) THEN node^.typ := OPT.sinttyp
  142.         ELSIF (OPM.MinInt <= v) & (v <= OPM.MaxInt) THEN node^.typ := OPT.inttyp
  143.         ELSIF (OPM.MinLInt <= v) & (v <= OPM.MaxLInt) (*bootstrap or cross*) THEN
  144.             node^.typ := OPT.linttyp
  145.         ELSE err(203); node^.typ := OPT.sinttyp; node^.conval^.intval := 1
  146.         END
  147.     END SetIntType;
  148.     PROCEDURE NewIntConst*(intval: LONGINT): OPT.Node;
  149.         VAR x: OPT.Node;
  150.     BEGIN
  151.         x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst();
  152.         x^.conval^.intval := intval; SetIntType(x); RETURN x
  153.     END NewIntConst;
  154.     PROCEDURE NewRealConst*(realval: LONGREAL; typ: OPT.Struct): OPT.Node;
  155.         VAR x: OPT.Node;
  156.     BEGIN
  157.         x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst();
  158.         x^.conval^.realval := realval; x^.typ := typ; x^.conval^.intval := OPM.ConstNotAlloc;
  159.         RETURN x
  160.     END NewRealConst;
  161.     PROCEDURE NewString*(VAR str: OPS.String; len: LONGINT): OPT.Node;
  162.         VAR x: OPT.Node;
  163.     BEGIN
  164.         x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp;
  165.         x^.conval^.intval := OPM.ConstNotAlloc; x^.conval^.intval2 := len;
  166.         x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str;
  167.         RETURN x
  168.     END NewString;
  169.     PROCEDURE CharToString(n: OPT.Node);
  170.         VAR ch: CHAR;
  171.     BEGIN
  172.         n^.typ := OPT.stringtyp; ch := CHR(n^.conval^.intval); n^.conval^.ext := OPT.NewExt();
  173.         IF ch = 0X THEN n^.conval^.intval2 := 1 ELSE n^.conval^.intval2 := 2; n^.conval^.ext[1] := 0X END ;
  174.         n^.conval^.ext[0] := ch; n^.conval^.intval := OPM.ConstNotAlloc; n^.obj := NIL
  175.     END CharToString;
  176.     PROCEDURE BindNodes(class: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node);
  177.         VAR node: OPT.Node;
  178.     BEGIN
  179.         node := OPT.NewNode(class); node^.typ := typ;
  180.         node^.left := x; node^.right := y; x := node
  181.     END BindNodes;
  182.     PROCEDURE NotVar(x: OPT.Node): BOOLEAN;
  183.     BEGIN RETURN (x^.class >= Nconst) & ((x^.class # Nmop) OR (x^.subcl # val) OR (x^.left^.class >= Nconst))
  184.     END NotVar;
  185.     PROCEDURE DeRef*(VAR x: OPT.Node);
  186.     BEGIN
  187.         IF x^.class >= Nconst THEN err(78)
  188.         ELSIF x^.typ^.form = Pointer THEN BindNodes(Nderef, x^.typ^.BaseTyp, x, NIL)
  189.         ELSE err(84)
  190.         END
  191.     END DeRef;
  192.     PROCEDURE Index*(VAR x: OPT.Node; y: OPT.Node);
  193.         VAR f: INTEGER; typ: OPT.Struct;
  194.     BEGIN
  195.         f := y^.typ^.form;
  196.         IF x^.class >= Nconst THEN err(79)
  197.         ELSIF ~(f IN intSet) THEN err(80); y^.typ := OPT.inttyp END ;
  198.         IF x^.typ^.comp = Array THEN typ := x^.typ^.BaseTyp;
  199.             IF (y^.class = Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END
  200.         ELSIF x^.typ^.comp = DynArr THEN typ := x^.typ^.BaseTyp;
  201.             IF (y^.class = Nconst) & (y^.conval^.intval < 0) THEN err(81) END
  202.         ELSE err(82); typ := OPT.undftyp
  203.         END ;
  204.         BindNodes(Nindex, typ, x, y); x^.readonly := x^.left^.readonly
  205.     END Index;
  206.     PROCEDURE Field*(VAR x: OPT.Node; y: OPT.Object);
  207.     BEGIN (*x^.typ^.comp = Record*)
  208.         IF x^.class >= Nconst THEN err(77)
  209.         ELSIF (y # NIL) & (y^.mode IN {Fld, TProc}) THEN
  210.             BindNodes(Nfield, y^.typ, x, NIL); x^.obj := y;
  211.             x^.readonly := x^.left^.readonly OR ((y^.vis = externalR) & (y^.mnolev < 0))
  212.         ELSE err(83); x^.typ := OPT.undftyp
  213.         END
  214.     END Field;
  215.     PROCEDURE TypTest*(VAR x: OPT.Node; obj: OPT.Object; guard: BOOLEAN);
  216.         VAR lg: OPT.Struct;    (* lg = last guard typ *)
  217.         PROCEDURE GTT(t0, t1: OPT.Struct);
  218.             VAR node: OPT.Node;
  219.         BEGIN
  220.             IF t0 # t1 THEN
  221.                 WHILE (t1 # NIL) & (t1 # lg) & (t1 # OPT.undftyp) DO t1 := t1^.BaseTyp END ;
  222.                 IF (x^.typ = OPT.sysptrtyp) OR (t1 # NIL) THEN
  223.                     IF guard THEN BindNodes(Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly    (* skip last guard *)
  224.                     ELSE node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  225.                         node^.obj := obj; x := node
  226.                     END
  227.                 ELSE err(85)
  228.                 END
  229.             ELSIF ~guard THEN x := NewBoolConst(TRUE)
  230.             END
  231.         END GTT;
  232.     BEGIN
  233.         IF NotVar(x) THEN err(112)
  234.         ELSE lg := x^.typ;
  235.             IF x^.class = Nguard THEN x := x^.left END ;    (* skip last (and unique) guard *)
  236.             IF x^.typ^.form = Pointer THEN
  237.                 IF (x^.typ # OPT.sysptrtyp) & (x^.typ^.BaseTyp^.comp # Record) THEN err(85)
  238.                 ELSE lg := lg^.BaseTyp;
  239.                     IF obj^.typ^.form = Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp)
  240.                     ELSE err(86)
  241.                     END
  242.                 END
  243.             ELSIF (x^.typ^.comp = Record) & (x^.class = Nvarpar) & (obj^.typ^.comp = Record) THEN
  244.                 GTT(x^.typ, obj^.typ)
  245.             ELSE err(87)
  246.             END
  247.         END ;
  248.         IF guard THEN x^.typ := obj^.typ ELSE x^.typ := OPT.booltyp END
  249.     END TypTest;
  250.     PROCEDURE TypTest*(VAR x: OPT.Node; obj: OPT.Object; guard: BOOLEAN);
  251.         PROCEDURE GTT(t0, t1: OPT.Struct);
  252.             VAR node: OPT.Node; t: OPT.Struct;
  253.         BEGIN t := t0;
  254.             WHILE (t # NIL) & (t # t1) & (t # OPT.undftyp) DO t := t^.BaseTyp END ;
  255.             IF t # t1 THEN
  256.                 WHILE (t1 # NIL) & (t1 # t0) & (t1 # OPT.undftyp) DO t1 := t1^.BaseTyp END ;
  257.                 IF (t1 = t0) OR (x^.typ = OPT.sysptrtyp) THEN
  258.                     IF guard THEN BindNodes(Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly
  259.                     ELSE node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  260.                         node^.obj := obj; x := node
  261.                     END
  262.                 ELSE err(85)
  263.                 END
  264.             ELSIF ~guard THEN
  265.                 IF x^.class = Nguard THEN    (* cannot skip guard *)
  266.                     node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  267.                     node^.obj := obj; x := node
  268.                 ELSE x := NewBoolConst(TRUE)
  269.                 END
  270.             END
  271.         END GTT;
  272.     BEGIN
  273.         IF NotVar(x) THEN err(112)
  274.         ELSIF x^.typ^.form = Pointer THEN
  275.             IF (x^.typ = OPT.sysptrtyp) & (obj^.typ^.form = Pointer) THEN GTT(x^.typ, obj^.typ^.BaseTyp)
  276.             ELSIF x^.typ^.BaseTyp^.comp # Record THEN err(85)
  277.             ELSIF obj^.typ^.form = Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp)
  278.             ELSE err(86)
  279.             END
  280.         ELSIF (x^.typ^.comp = Record) & (x^.class = Nvarpar) & (obj^.typ^.comp = Record) THEN
  281.             GTT(x^.typ, obj^.typ)
  282.         ELSE err(87)
  283.         END ;
  284.         IF guard THEN x^.typ := obj^.typ ELSE x^.typ := OPT.booltyp END
  285.     END TypTest;
  286.     PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node);
  287.         VAR f: INTEGER; k: LONGINT;
  288.     BEGIN f := x^.typ^.form;
  289.         IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  290.         ELSIF (f IN intSet) & (y^.typ^.form = Set) THEN
  291.             IF x^.class = Nconst THEN
  292.                 k := x^.conval^.intval;
  293.                 IF (k < 0) OR (k > OPM.MaxSet) THEN err(202)
  294.                 ELSIF y^.class = Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL
  295.                 ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in
  296.                 END
  297.             ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in
  298.             END
  299.         ELSE err(92)
  300.         END ;
  301.         x^.typ := OPT.booltyp
  302.     END In;
  303.     PROCEDURE log(x: LONGINT): LONGINT;
  304.     BEGIN exp := 0;
  305.         IF x > 0 THEN
  306.             WHILE ~ODD(x) DO x := x DIV 2; INC(exp) END
  307.         END ;
  308.         RETURN x
  309.     END log;
  310.     PROCEDURE CheckRealType(f, nr: INTEGER; x: OPT.Const);
  311.         VAR min, max, r: LONGREAL;
  312.     BEGIN
  313.         IF f = Real THEN min := OPM.MinReal; max := OPM.MaxReal
  314.         ELSE min := OPM.MinLReal; max := OPM.MaxLReal
  315.         END ;
  316.         r := ABS(x^.realval);
  317.         IF (r > max) OR (r < min) THEN
  318.                 err(nr); x^.realval := 1.0
  319.         ELSIF f = Real THEN x^.realval := SHORT(x^.realval)    (* single precision only *)
  320.         END ;
  321.         x^.intval := OPM.ConstNotAlloc
  322.     END CheckRealType;
  323.     PROCEDURE MOp*(op: SHORTINT; VAR x: OPT.Node);
  324.         VAR f: INTEGER; typ: OPT.Struct; z: OPT.Node;
  325.         PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; z: OPT.Node): OPT.Node;
  326.             VAR node: OPT.Node;
  327.         BEGIN
  328.             node := OPT.NewNode(Nmop); node^.subcl := op; node^.typ := typ;
  329.             node^.left := z; RETURN node
  330.         END NewOp;
  331.     BEGIN z := x;
  332.         IF (z^.class = Ntype) OR (z^.class = Nproc) THEN err(126)
  333.         ELSE typ := z^.typ; f := typ^.form;
  334.             CASE op OF
  335.               not:
  336.                     IF f = Bool THEN
  337.                         IF z^.class = Nconst THEN
  338.                             z^.conval^.intval := BoolToInt(~IntToBool(z^.conval^.intval)); z^.obj := NIL
  339.                         ELSE z := NewOp(op, typ, z)
  340.                         END
  341.                     ELSE err(98)
  342.                     END
  343.             | plus:
  344.                     IF ~(f IN intSet + realSet) THEN err(96) END
  345.             | minus:
  346.                     IF f IN intSet + realSet +{Set}THEN
  347.                         IF z^.class = Nconst THEN
  348.                             IF f IN intSet THEN
  349.                                 IF z^.conval^.intval = MIN(LONGINT) THEN err(203)
  350.                                 ELSE z^.conval^.intval := -z^.conval^.intval; SetIntType(z)
  351.                                 END
  352.                             ELSIF f IN realSet THEN z^.conval^.realval := -z^.conval^.realval
  353.                             ELSE z^.conval^.setval := -z^.conval^.setval
  354.                             END ;
  355.                             z^.obj := NIL
  356.                         ELSE z := NewOp(op, typ, z)
  357.                         END
  358.                     ELSE err(97)
  359.                     END
  360.             | abs:
  361.                     IF f IN intSet + realSet THEN
  362.                         IF z^.class = Nconst THEN
  363.                             IF f IN intSet THEN
  364.                                 IF z^.conval^.intval = MIN(LONGINT) THEN err(203)
  365.                                 ELSE z^.conval^.intval := ABS(z^.conval^.intval); SetIntType(z)
  366.                                 END
  367.                             ELSE z^.conval^.realval := ABS(z^.conval^.realval)
  368.                             END ;
  369.                             z^.obj := NIL
  370.                         ELSE z := NewOp(op, typ, z)
  371.                         END
  372.                     ELSE err(111)
  373.                     END
  374.             | cap:
  375.                     IF f = Char THEN
  376.                         IF z^.class = Nconst THEN
  377.                             z^.conval^.intval := ORD(CAP(CHR(z^.conval^.intval))); z^.obj := NIL
  378.                         ELSE z := NewOp(op, typ, z)
  379.                         END
  380.                     ELSE err(111); z^.typ := OPT.chartyp
  381.                     END
  382.             | odd:
  383.                     IF f IN intSet THEN
  384.                         IF z^.class = Nconst THEN
  385.                             z^.conval^.intval := BoolToInt(ODD(z^.conval^.intval)); z^.obj := NIL
  386.                         ELSE z := NewOp(op, typ, z)
  387.                         END
  388.                     ELSE err(111)
  389.                     END ;
  390.                     z^.typ := OPT.booltyp
  391.             | adr: (*SYSTEM.ADR*)
  392.                     IF (z^.class < Nconst) OR (f = String) THEN z := NewOp(op, typ, z)
  393.                     ELSE err(127)
  394.                     END ;
  395.                     z^.typ := OPT.linttyp
  396.             | cc: (*SYSTEM.CC*)
  397.                     IF (f IN intSet) & (z^.class = Nconst) THEN
  398.                         IF (0 <= z^.conval^.intval) & (z^.conval^.intval <= OPM.MaxCC) THEN z := NewOp(op, typ, z) ELSE err(219) END
  399.                     ELSE err(69)
  400.                     END ;
  401.                     z^.typ := OPT.booltyp
  402.             END
  403.         END ;
  404.         x := z
  405.     END MOp;
  406.     PROCEDURE CheckPtr(x, y: OPT.Node);
  407.         VAR g: INTEGER; p, q, t: OPT.Struct;
  408.     BEGIN g := y^.typ^.form;
  409.         IF g = Pointer THEN
  410.             p := x^.typ^.BaseTyp; q := y^.typ^.BaseTyp;
  411.             IF (p^.comp = Record) & (q^.comp = Record) THEN
  412.                 IF p^.extlev < q^.extlev THEN t := p; p := q; q := t END ;
  413.                 WHILE (p # q) & (p # NIL) & (p # OPT.undftyp) DO p := p^.BaseTyp END ;
  414.                 IF p = NIL THEN err(100) END
  415.             ELSE err(100)
  416.             END
  417.         ELSIF g # NilTyp THEN err(100)
  418.         END
  419.     END CheckPtr;
  420.     PROCEDURE CheckParameters*(fp, ap: OPT.Object; checkNames: BOOLEAN);
  421.         VAR ft, at: OPT.Struct;
  422.     BEGIN
  423.         WHILE fp # NIL DO
  424.             IF ap # NIL THEN
  425.                 ft := fp^.typ; at := ap^.typ;
  426.                 WHILE (ft^.comp = DynArr) & (at^.comp = DynArr) DO
  427.                     ft := ft^.BaseTyp; at := at^.BaseTyp
  428.                 END ;
  429.                 IF ft # at THEN
  430.                     IF (ft^.form = ProcTyp) & (at^.form = ProcTyp) THEN
  431.                         IF ft^.BaseTyp = at^.BaseTyp THEN CheckParameters(ft^.link, at^.link, FALSE)
  432.                         ELSE err(117)
  433.                         END
  434.                     ELSE err(115)
  435.                     END
  436.                 END ;
  437.                 IF (fp^.mode # ap^.mode) OR checkNames & (fp^.name # ap^.name) THEN err(115) END ;
  438.                 ap := ap^.link
  439.             ELSE err(116)
  440.             END ;
  441.             fp := fp^.link
  442.         END ;
  443.         IF ap # NIL THEN err(116) END
  444.     END CheckParameters;
  445.     PROCEDURE CheckProc(x: OPT.Struct; y: OPT.Object);    (* proc var x := proc y, check compatibility *)
  446.     BEGIN
  447.         IF y^.mode IN {XProc, IProc, LProc} THEN
  448.             IF y^.mode = LProc THEN
  449.                 IF y^.mnolev = 0 THEN y^.mode := XProc
  450.                 ELSE err(73)
  451.                 END
  452.             END ;
  453.             IF x^.BaseTyp = y^.typ THEN CheckParameters(x^.link, y^.link, FALSE)
  454.             ELSE err(117)
  455.             END
  456.         ELSE err(113)
  457.         END
  458.     END CheckProc;
  459.     PROCEDURE ConstOp(op: INTEGER; x, y: OPT.Node);
  460.         VAR f, g: INTEGER; xval, yval: OPT.Const; xv, yv: LONGINT;
  461.                 temp: BOOLEAN; (* temp avoids err 215 *)
  462.         PROCEDURE ConstCmp(): INTEGER;
  463.             VAR res: INTEGER;
  464.         BEGIN
  465.             CASE f OF
  466.               Undef:
  467.                     res := eql
  468.             | Byte, Char..LInt:
  469.                     IF xval^.intval < yval^.intval THEN res := lss
  470.                     ELSIF xval^.intval > yval^.intval THEN res := gtr
  471.                     ELSE res := eql
  472.                     END
  473.             | Real, LReal:
  474.                     IF xval^.realval < yval^.realval THEN res := lss
  475.                     ELSIF xval^.realval > yval^.realval THEN res := gtr
  476.                     ELSE res := eql
  477.                     END
  478.             | Bool:
  479.                     IF xval^.intval # yval^.intval THEN res := neq
  480.                     ELSE res := eql
  481.                     END
  482.             | Set:
  483.                     IF xval^.setval # yval^.setval THEN res := neq
  484.                     ELSE res := eql
  485.                     END
  486.             | String:
  487.                     IF xval^.ext^ < yval^.ext^ THEN res := lss
  488.                     ELSIF xval^.ext^ > yval^.ext^ THEN res := gtr
  489.                     ELSE res := eql
  490.                     END
  491.             | NilTyp, Pointer, ProcTyp:
  492.                     IF xval^.intval # yval^.intval THEN res := neq
  493.                     ELSE res := eql
  494.                     END
  495.             END ;
  496.             x^.typ := OPT.booltyp; RETURN res
  497.         END ConstCmp;
  498.     BEGIN
  499.         f := x^.typ^.form; g := y^.typ^.form; xval := x^.conval; yval := y^.conval;
  500.         IF f # g THEN
  501.             CASE f OF
  502.               Char:
  503.                     IF g = String THEN CharToString(x)
  504.                     ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  505.                     END ;
  506.             | SInt:
  507.                     IF g IN intSet THEN x^.typ := y^.typ
  508.                     ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  509.                     ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  510.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  511.                     END
  512.             | Int:
  513.                     IF g = SInt THEN y^.typ := OPT.inttyp
  514.                     ELSIF g IN intSet THEN x^.typ := y^.typ
  515.                     ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  516.                     ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  517.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  518.                     END
  519.             | LInt:
  520.                     IF g IN intSet THEN y^.typ := OPT.linttyp
  521.                     ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  522.                     ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  523.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  524.                     END
  525.             | Real:
  526.                     IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval
  527.                     ELSIF g = LReal THEN x^.typ := OPT.lrltyp
  528.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  529.                     END
  530.             | LReal:
  531.                     IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval
  532.                     ELSIF g = Real THEN y^.typ := OPT.lrltyp
  533.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  534.                     END
  535.             | String:
  536.                     IF g = Char THEN CharToString(y); g := String
  537.                     ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  538.                     END ;
  539.             | NilTyp:
  540.                     IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END
  541.             | Pointer:
  542.                     CheckPtr(x, y)
  543.             | ProcTyp:
  544.                     IF g # NilTyp THEN err(100) END
  545.             ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  546.             END ;
  547.             f := x^.typ^.form
  548.         END ;    (* {x^.typ = y^.typ} *)
  549.         CASE op OF
  550.           times:
  551.                 IF f IN intSet THEN xv := xval^.intval; yv := yval^.intval;
  552.                     IF (xv = 0) OR (yv = 0) OR    (* division with negative numbers is not defined *)
  553.                         (xv > 0) & (yv > 0) & (yv <= MAX(LONGINT) DIV xv) OR
  554.                         (xv > 0) & (yv < 0) & (yv >= MIN(LONGINT) DIV xv) OR
  555.                         (xv < 0) & (yv > 0) & (xv >= MIN(LONGINT) DIV yv) OR
  556.                         (xv < 0) & (yv < 0) & (xv # MIN(LONGINT)) & (yv # MIN(LONGINT)) & (-xv <= MAX(LONGINT) DIV (-yv)) THEN
  557.                         xval^.intval := xv * yv; SetIntType(x)
  558.                     ELSE err(204)
  559.                     END
  560.                 ELSIF f IN realSet THEN
  561.                     temp := ABS(yval^.realval) <= 1.0;
  562.                     IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN
  563.                         xval^.realval := xval^.realval * yval^.realval; CheckRealType(f, 204, xval)
  564.                     ELSE err(204)
  565.                     END
  566.                 ELSIF f = Set THEN
  567.                     xval^.setval := xval^.setval * yval^.setval
  568.                 ELSIF f # Undef THEN err(101)
  569.                 END
  570.         | slash:
  571.                 IF f IN intSet THEN
  572.                     IF yval^.intval # 0 THEN
  573.                         xval^.realval := xval^.intval / yval^.intval; CheckRealType(Real, 205, xval)
  574.                     ELSE err(205); xval^.realval := 1.0
  575.                     END ;
  576.                     x^.typ := OPT.realtyp
  577.                 ELSIF f IN realSet THEN
  578.                     temp := ABS(yval^.realval) >= 1.0;
  579.                     IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN
  580.                         xval^.realval := xval^.realval / yval^.realval; CheckRealType(f, 205, xval)
  581.                     ELSE err(205)
  582.                     END
  583.                 ELSIF f = Set THEN
  584.                     xval^.setval := xval^.setval / yval^.setval
  585.                 ELSIF f # Undef THEN err(102)
  586.                 END
  587.         | div:
  588.                 IF f IN intSet THEN
  589.                     IF yval^.intval # 0 THEN
  590.                         xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x)
  591.                     ELSE err(205)
  592.                     END
  593.                 ELSIF f # Undef THEN err(103)
  594.                 END
  595.         | mod:
  596.                 IF f IN intSet THEN
  597.                     IF yval^.intval # 0 THEN
  598.                         xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x)
  599.                     ELSE err(205)
  600.                     END
  601.                 ELSIF f # Undef THEN err(104)
  602.                 END
  603.         | and:
  604.                 IF f = Bool THEN
  605.                     xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval))
  606.                 ELSE err(94)
  607.                 END
  608.         | plus:
  609.                 IF f IN intSet THEN
  610.                     temp := (yval^.intval >= 0) & (xval^.intval <= MAX(LONGINT) - yval^.intval);
  611.                     IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN
  612.                             INC(xval^.intval, yval^.intval); SetIntType(x)
  613.                     ELSE err(206)
  614.                     END
  615.                 ELSIF f IN realSet THEN
  616.                     temp := (yval^.realval >= 0.0) & (xval^.realval <= MAX(LONGREAL) - yval^.realval);
  617.                     IF temp OR (yval^.realval < 0.0) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN
  618.                             xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval)
  619.                     ELSE err(206)
  620.                     END
  621.                 ELSIF f = Set THEN
  622.                     xval^.setval := xval^.setval + yval^.setval
  623.                 ELSIF f # Undef THEN err(105)
  624.                 END
  625.         | minus:
  626.                 IF f IN intSet THEN
  627.                     IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR
  628.                         (yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN
  629.                             DEC(xval^.intval, yval^.intval); SetIntType(x)
  630.                     ELSE err(207)
  631.                     END
  632.                 ELSIF f IN realSet THEN
  633.                     temp := (yval^.realval >= 0.0) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval);
  634.                     IF temp OR (yval^.realval < 0.0) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN
  635.                             xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval)
  636.                     ELSE err(207)
  637.                     END
  638.                 ELSIF f = Set THEN
  639.                     xval^.setval := xval^.setval - yval^.setval
  640.                 ELSIF f # Undef THEN err(106)
  641.                 END
  642.         | or:
  643.                 IF f = Bool THEN
  644.                     xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval))
  645.                 ELSE err(95)
  646.                 END
  647.         | eql:
  648.                 xval^.intval := BoolToInt(ConstCmp() = eql)
  649.         | neq:
  650.                 xval^.intval := BoolToInt(ConstCmp() # eql)
  651.         | lss:
  652.                 IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  653.                 ELSE xval^.intval := BoolToInt(ConstCmp() = lss)
  654.                 END
  655.         | leq:
  656.                 IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  657.                 ELSE xval^.intval := BoolToInt(ConstCmp() # gtr)
  658.                 END
  659.         | gtr:
  660.                 IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  661.                 ELSE xval^.intval := BoolToInt(ConstCmp() = gtr)
  662.                 END
  663.         | geq:
  664.                 IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  665.                 ELSE xval^.intval := BoolToInt(ConstCmp() # lss)
  666.                 END
  667.         END
  668.     END ConstOp;
  669.     PROCEDURE Convert(VAR x: OPT.Node; typ: OPT.Struct);
  670.         VAR node: OPT.Node; f, g: INTEGER; k: LONGINT; r: LONGREAL;
  671.     BEGIN f := x^.typ^.form; g := typ^.form;
  672.         IF x^.class = Nconst THEN
  673.             IF f IN intSet THEN
  674.                 IF g IN intSet THEN
  675.                     IF f > g THEN SetIntType(x);
  676.                         IF x^.typ^.form > g THEN err(203); x^.conval^.intval := 1 END
  677.                     END
  678.                 ELSIF g IN realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc
  679.                 ELSE (*g = Char*) k := x^.conval^.intval;
  680.                     IF (0 > k) OR (k > 0FFH) THEN err(220) END
  681.                 END
  682.             ELSIF f IN realSet THEN
  683.                 IF g IN realSet THEN CheckRealType(g, 203, x^.conval)
  684.                 ELSE (*g = LInt*)
  685.                     r := x^.conval^.realval;
  686.                     IF (r < MIN(LONGINT)) OR (r > MAX(LONGINT)) THEN err(203); r := 1 END ;
  687.                     x^.conval^.intval := ENTIER(r); SetIntType(x)
  688.                 END
  689.             ELSE (* (f IN {Char, Byte}) & (g IN {Byte} + intSet) OR (f = Undef) *)
  690.             END ;
  691.             x^.obj := NIL
  692.         ELSIF (x^.class = Nmop) & (x^.subcl = conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN
  693.             (* don't create new node *)
  694.             IF x^.left^.typ = typ THEN (* and suppress existing node *) x := x^.left END
  695.         ELSE node := OPT.NewNode(Nmop); node^.subcl := conv; node^.left := x; x := node
  696.         END ;
  697.         x^.typ := typ
  698.     END Convert;
  699.     PROCEDURE Op*(op: SHORTINT; VAR x: OPT.Node; y: OPT.Node);
  700.         VAR f, g: INTEGER; t, z: OPT.Node; typ: OPT.Struct; do: BOOLEAN; val: LONGINT;
  701.         PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node);
  702.             VAR node: OPT.Node;
  703.         BEGIN
  704.             node := OPT.NewNode(Ndop); node^.subcl := op; node^.typ := typ;
  705.             node^.left := x; node^.right := y; x := node
  706.         END NewOp;
  707.         PROCEDURE strings(VAR x, y: OPT.Node): BOOLEAN;
  708.             VAR ok, xCharArr, yCharArr: BOOLEAN;
  709.         BEGIN
  710.             xCharArr := ((x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form=Char)) OR (f=String);
  711.             yCharArr := (((y^.typ^.comp IN {Array, DynArr}) & (y^.typ^.BaseTyp^.form=Char)) OR (g=String));
  712.             IF xCharArr & (g = Char) & (y^.class = Nconst) THEN CharToString(y); g := String; yCharArr := TRUE END ;
  713.             IF yCharArr & (f = Char) & (x^.class = Nconst) THEN CharToString(x); f := String; xCharArr := TRUE END ;
  714.             ok := xCharArr & yCharArr;
  715.             IF ok THEN    (* replace ""-string compare with 0X-char compare, if possible *)
  716.                 IF (f=String) & (x^.conval^.intval2 = 1) THEN    (* y is array of char *)
  717.                     x^.typ := OPT.chartyp; x^.conval^.intval := 0;
  718.                     Index(y, NewIntConst(0))
  719.                 ELSIF (g=String) & (y^.conval^.intval2 = 1) THEN    (* x is array of char *)
  720.                     y^.typ := OPT.chartyp; y^.conval^.intval := 0;
  721.                     Index(x, NewIntConst(0))
  722.                 END
  723.             END ;
  724.             RETURN ok
  725.         END strings;
  726.     BEGIN z := x;
  727.         IF (z^.class = Ntype) OR (z^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  728.         ELSIF (z^.class = Nconst) & (y^.class = Nconst) THEN ConstOp(op, z, y); z^.obj := NIL
  729.         ELSE
  730.             IF z^.typ # y^.typ THEN
  731.                 g := y^.typ^.form;
  732.                 CASE z^.typ^.form OF
  733.                    Char: IF z^.class = Nconst THEN CharToString(z) ELSE err(100) END
  734.                 | SInt:
  735.                         IF g IN intSet + realSet THEN Convert(z, y^.typ)
  736.                         ELSE  err(100)
  737.                         END
  738.                 | Int:
  739.                         IF g = SInt THEN Convert(y, z^.typ)
  740.                         ELSIF g IN intSet + realSet THEN Convert(z, y^.typ)
  741.                         ELSE  err(100)
  742.                         END
  743.                 | LInt:
  744.                         IF g IN intSet THEN Convert(y, z^.typ)
  745.                         ELSIF g IN realSet THEN Convert(z, y^.typ)
  746.                         ELSE  err(100)
  747.                         END
  748.                 | Real:
  749.                         IF g IN intSet THEN Convert(y, z^.typ)
  750.                         ELSIF g IN realSet THEN Convert(z, y^.typ)
  751.                         ELSE  err(100)
  752.                         END
  753.                 | LReal:
  754.                         IF g IN intSet + realSet THEN Convert(y, z^.typ)
  755.                         ELSIF g IN realSet THEN Convert(y, z^.typ)
  756.                         ELSE  err(100)
  757.                         END
  758.                 | NilTyp:
  759.                         IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END
  760.                 | Pointer:
  761.                         CheckPtr(z, y)
  762.                 | ProcTyp:
  763.                         IF g # NilTyp THEN err(100) END
  764.                 | String:
  765.                 | Comp:
  766.                         IF z^.typ^.comp = Record THEN err(100) END
  767.                 ELSE err(100)
  768.                 END
  769.             END ;    (* {z^.typ = y^.typ} *)
  770.             typ := z^.typ; f := typ^.form; g := y^.typ^.form;
  771.             CASE op OF
  772.               times:
  773.                     do := TRUE;
  774.                     IF f IN intSet THEN
  775.                         IF z^.class = Nconst THEN val := z^.conval^.intval;
  776.                             IF val = 1 THEN do := FALSE; z := y
  777.                             ELSIF val = 0 THEN do := FALSE
  778.                             ELSIF log(val) = 1 THEN
  779.                                 t := y; y := z; z := t;
  780.                                 op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL
  781.                             END
  782.                         ELSIF y^.class = Nconst THEN val := y^.conval^.intval;
  783.                             IF val = 1 THEN do := FALSE
  784.                             ELSIF val = 0 THEN do := FALSE; z := y
  785.                             ELSIF log(val) = 1 THEN
  786.                                 op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL
  787.                             END
  788.                         END
  789.                     ELSIF ~(f IN {Undef, Real..Set}) THEN err(105); typ := OPT.undftyp
  790.                     END ;
  791.                     IF do THEN NewOp(op, typ, z, y) END
  792.             | slash:
  793.                     IF f IN intSet THEN
  794.                         IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN err(205) END ;
  795.                         Convert(z, OPT.realtyp); Convert(y, OPT.realtyp);
  796.                         typ := OPT.realtyp
  797.                     ELSIF f IN realSet THEN
  798.                         IF (y^.class = Nconst) & (y^.conval^.realval = 0.0) THEN err(205) END
  799.                     ELSIF (f # Set) & (f # Undef) THEN err(102); typ := OPT.undftyp
  800.                     END ;
  801.                     NewOp(op, typ, z, y)
  802.             | div:
  803.                     do := TRUE;
  804.                     IF f IN intSet THEN
  805.                         IF y^.class = Nconst THEN val := y^.conval^.intval;
  806.                             IF val = 0 THEN err(205)
  807.                             ELSIF val = 1 THEN do := FALSE
  808.                             ELSIF log(val) = 1 THEN
  809.                                 op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL
  810.                             END
  811.                         END
  812.                     ELSIF f # Undef THEN err(103); typ := OPT.undftyp
  813.                     END ;
  814.                     IF do THEN NewOp(op, typ, z, y) END
  815.             | mod:
  816.                     IF f IN intSet THEN
  817.                         IF y^.class = Nconst THEN
  818.                             IF y^.conval^.intval = 0 THEN err(205)
  819.                             ELSIF log(y^.conval^.intval) = 1 THEN
  820.                                 op := msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL
  821.                             END
  822.                         END
  823.                     ELSIF f # Undef THEN err(104); typ := OPT.undftyp
  824.                     END ;
  825.                     NewOp(op, typ, z, y)
  826.             | and:
  827.                     IF f = Bool THEN
  828.                         IF z^.class = Nconst THEN
  829.                             IF IntToBool(z^.conval^.intval) THEN z := y END
  830.                         ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize z & TRUE -> z *)
  831.                 (*    ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN
  832.                             don't optimize z & FALSE -> FALSE: side effects possible    *)
  833.                         ELSE NewOp(op, typ, z, y)
  834.                         END
  835.                     ELSIF f # Undef THEN err(94); z^.typ := OPT.undftyp
  836.                     END
  837.             | plus:
  838.                     IF ~(f IN {Undef, SInt..Set}) THEN err(105); typ := OPT.undftyp END ;
  839.                     do := TRUE;
  840.                     IF f IN intSet THEN
  841.                         IF (z^.class = Nconst) & (z^.conval^.intval = 0) THEN do := FALSE; z := y END ;
  842.                         IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END
  843.                     END ;
  844.                     IF do THEN NewOp(op, typ, z, y) END
  845.             | minus:
  846.                     IF ~(f IN {Undef, SInt..Set}) THEN err(106); typ := OPT.undftyp END ;
  847.                     IF ~(f IN intSet) OR (y^.class # Nconst) OR (y^.conval^.intval # 0) THEN NewOp(op, typ, z, y) END
  848.             | or:
  849.                     IF f = Bool THEN
  850.                         IF z^.class = Nconst THEN
  851.                             IF ~IntToBool(z^.conval^.intval) THEN z := y END
  852.                         ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize z OR FALSE -> z *)
  853.                 (*    ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN
  854.                             don't optimize z OR TRUE -> TRUE: side effects possible    *)
  855.                         ELSE NewOp(op, typ, z, y)
  856.                         END
  857.                     ELSIF f # Undef THEN err(95); z^.typ := OPT.undftyp
  858.                     END
  859.             | eql, neq:
  860.                     IF (f IN {Undef..Set, NilTyp, Pointer, ProcTyp}) OR strings(z, y) THEN typ := OPT.booltyp
  861.                     ELSE err(107); typ := OPT.undftyp
  862.                     END ;
  863.                     NewOp(op, typ, z, y)
  864.             | lss, leq, gtr, geq:
  865.                     IF (f IN {Undef, Char..LReal}) OR strings(z, y) THEN typ := OPT.booltyp
  866.                     ELSE err(108); typ := OPT.undftyp
  867.                     END ;
  868.                     NewOp(op, typ, z, y)
  869.             END
  870.         END ;
  871.         x := z
  872.     END Op;
  873.     PROCEDURE SetRange*(VAR x: OPT.Node; y: OPT.Node);
  874.         VAR k, l: LONGINT;
  875.     BEGIN
  876.         IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  877.         ELSIF (x^.typ^.form IN intSet) & (y^.typ^.form IN intSet) THEN
  878.             IF x^.class = Nconst THEN
  879.                 k := x^.conval^.intval;
  880.                 IF (0 > k) OR (k > OPM.MaxSet) THEN err(202) END
  881.             END ;
  882.             IF y^.class = Nconst THEN
  883.                 l := y^.conval^.intval;
  884.                 IF (0 > l) OR (l > OPM.MaxSet) THEN err(202) END
  885.             END ;
  886.             IF (x^.class = Nconst) & (y^.class = Nconst) THEN
  887.                 IF k <= l THEN
  888.                     x^.conval^.setval := {k..l}
  889.                 ELSE err(201); x^.conval^.setval := {l..k}
  890.                 END ;
  891.                 x^.obj := NIL
  892.             ELSE BindNodes(Nupto, OPT.settyp, x, y)
  893.             END
  894.         ELSE err(93)
  895.         END ;
  896.         x^.typ := OPT.settyp
  897.     END SetRange;
  898.     PROCEDURE SetElem*(VAR x: OPT.Node);
  899.         VAR k: LONGINT;
  900.     BEGIN
  901.         IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  902.         ELSIF ~(x^.typ^.form IN intSet) THEN err(93)
  903.         ELSIF x^.class = Nconst THEN
  904.             k := x^.conval^.intval;
  905.             IF (0 <= k) & (k <= OPM.MaxSet) THEN x^.conval^.setval := {k}
  906.             ELSE err(202)
  907.             END ;
  908.             x^.obj := NIL
  909.         ELSE Convert(x, OPT.settyp)
  910.         END ;
  911.         x^.typ := OPT.settyp
  912.     END SetElem;
  913.     PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node);    (* x := y *)
  914.         VAR f, g: INTEGER; y, p, q: OPT.Struct;
  915.     BEGIN
  916.         y := ynode^.typ; f := x^.form; g := y^.form;
  917.         IF (ynode^.class = Ntype) OR (ynode^.class = Nproc) & (f # ProcTyp) THEN err(126) END ;
  918.         CASE f OF
  919.           Undef, String:
  920.         | Byte:
  921.                 IF ~(g IN {Byte, Char, SInt}) THEN err(113) END
  922.         | Bool, Char, SInt, Set:
  923.                 IF g # f THEN err(113) END
  924.         | Int:
  925.                 IF ~(g IN {SInt, Int}) THEN err(113) END
  926.         | LInt:
  927.                 IF ~(g IN intSet) THEN err(113) END
  928.         | Real:
  929.                 IF ~(g IN {SInt..Real}) THEN err(113) END
  930.         | LReal:
  931.                 IF ~(g IN {SInt..LReal}) THEN err(113) END
  932.         | Pointer:
  933.                 IF (x = y) OR (g = NilTyp) OR (x = OPT.sysptrtyp) & (g = Pointer) THEN (* ok *)
  934.                 ELSIF g = Pointer THEN
  935.                     p := x^.BaseTyp; q := y^.BaseTyp;
  936.                     IF (p^.comp = Record) & (q^.comp = Record) THEN
  937.                         WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  938.                         IF q = NIL THEN err(113) END
  939.                     ELSE err(113)
  940.                     END
  941.                 ELSE err(113)
  942.                 END
  943.         | ProcTyp:
  944.                 IF ynode^.class = Nproc THEN CheckProc(x, ynode^.obj)
  945.                 ELSIF (x = y) OR (g = NilTyp) THEN (* ok *)
  946.                 ELSE err(113)
  947.                 END
  948.         | NoTyp, NilTyp:
  949.                 err(113)
  950.         | Comp:
  951.                 IF x^.comp = Array THEN
  952.                     IF (ynode^.class = Nconst) & (g = Char) THEN CharToString(ynode); y := ynode^.typ; g := String END ;
  953.                     IF x = y THEN (* ok *)
  954.                     ELSIF (g = String) & (x^.BaseTyp = OPT.chartyp) THEN (*check length of string*)
  955.                         IF ynode^.conval^.intval2 > x^.n THEN err(114) END ;
  956.                     ELSE err(113)
  957.                     END
  958.                 ELSIF x^.comp = Record THEN
  959.                     IF x = y THEN (* ok *)
  960.                     ELSIF y^.comp = Record THEN
  961.                         q := y^.BaseTyp;
  962.                         WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  963.                         IF q = NIL THEN err(113) END
  964.                     ELSE err(113)
  965.                     END
  966.                 ELSE (*DynArr*) err(113)
  967.                 END
  968.         END ;
  969.         IF (ynode^.class = Nconst) & (g < f) & (g IN {SInt..Real}) & (f IN {Int..LReal}) THEN
  970.             Convert(ynode, x)
  971.         END
  972.     END CheckAssign;
  973.     PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN);
  974.     BEGIN
  975.         IF (x^.class = Nmop) & (x^.subcl = val) THEN x := x^.left END ;
  976.         IF x^.class = Nguard THEN x := x^.left END ;    (* skip last (and unique) guard *)
  977.         IF (x^.class = Nvar) & (dynArrToo OR (x^.typ^.comp # DynArr)) THEN x^.obj^.leaf := FALSE END
  978.     END CheckLeaf;
  979.     PROCEDURE StPar0*(VAR par0: OPT.Node; fctno: INTEGER);    (* par0: first param of standard proc *)
  980.         VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node;
  981.     BEGIN x := par0; f := x^.typ^.form;
  982.         CASE fctno OF
  983.           haltfn: (*HALT*)
  984.                 IF (f IN intSet) & (x^.class = Nconst) THEN
  985.                     IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN
  986.                         BindNodes(Ntrap, OPT.notyp, x, x)
  987.                     ELSE err(218)
  988.                     END
  989.                 ELSE err(69)
  990.                 END ;
  991.                 x^.typ := OPT.notyp
  992.         | newfn: (*NEW*)
  993.                 typ := OPT.notyp;
  994.                 IF NotVar(x) THEN err(112)
  995.                 ELSIF f = Pointer THEN
  996.                     IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ;
  997.                     IF x^.readonly THEN err(76) END ;
  998.                     f := x^.typ^.BaseTyp^.comp;
  999.                     IF f IN {Record, DynArr, Array} THEN
  1000.                         IF f = DynArr THEN typ := x^.typ^.BaseTyp END ;
  1001.                         BindNodes(Nassign, OPT.notyp, x, NIL); x^.subcl := newfn
  1002.                     ELSE err(111)
  1003.                     END
  1004.                 ELSE err(111)
  1005.                 END ;
  1006.                 x^.typ := typ
  1007.         | absfn: (*ABS*)
  1008.                 MOp(abs, x)
  1009.         | capfn: (*CAP*)
  1010.                 MOp(cap, x)
  1011.         | ordfn: (*ORD*)
  1012.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1013.                 ELSIF f = Char THEN Convert(x, OPT.inttyp)
  1014.                 ELSE err(111)
  1015.                 END ;
  1016.                 x^.typ := OPT.inttyp
  1017.         | entierfn: (*ENTIER*)
  1018.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1019.                 ELSIF f IN realSet THEN Convert(x, OPT.linttyp)
  1020.                 ELSE err(111)
  1021.                 END ;
  1022.                 x^.typ := OPT.linttyp
  1023.         | oddfn: (*ODD*)
  1024.                 MOp(odd, x)
  1025.         | minfn: (*MIN*)
  1026.                 IF x^.class = Ntype THEN
  1027.                     CASE f OF
  1028.                       Bool:  x := NewBoolConst(FALSE)
  1029.                     | Char:  x := NewIntConst(0); x^.typ := OPT.chartyp
  1030.                     | SInt:  x := NewIntConst(OPM.MinSInt)
  1031.                     | Int:   x := NewIntConst(OPM.MinInt)
  1032.                     | LInt:  x := NewIntConst(OPM.MinLInt)
  1033.                     | Set:   x := NewIntConst(0); x^.typ := OPT.inttyp
  1034.                     | Real:  x := NewRealConst(OPM.MinReal, OPT.realtyp)
  1035.                     | LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp)
  1036.                     ELSE err(111)
  1037.                     END
  1038.                 ELSE err(110)
  1039.                 END
  1040.         | maxfn: (*MAX*)
  1041.                 IF x^.class = Ntype THEN
  1042.                     CASE f OF
  1043.                       Bool:  x := NewBoolConst(TRUE)
  1044.                     | Char:  x := NewIntConst(0FFH); x^.typ := OPT.chartyp
  1045.                     | SInt:  x := NewIntConst(OPM.MaxSInt)
  1046.                     | Int:   x := NewIntConst(OPM.MaxInt)
  1047.                     | LInt:  x := NewIntConst(OPM.MaxLInt)
  1048.                     | Set:   x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp
  1049.                     | Real:  x := NewRealConst(OPM.MaxReal, OPT.realtyp)
  1050.                     | LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp)
  1051.                     ELSE err(111)
  1052.                     END
  1053.                 ELSE err(110)
  1054.                 END
  1055.         | chrfn: (*CHR*)
  1056.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1057.                 ELSIF f IN {Undef, SInt..LInt} THEN Convert(x, OPT.chartyp)
  1058.                 ELSE err(111); x^.typ := OPT.chartyp
  1059.                 END
  1060.         | shortfn: (*SHORT*)
  1061.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1062.                 ELSIF f = Int THEN Convert(x, OPT.sinttyp)
  1063.                 ELSIF f = LInt THEN Convert(x, OPT.inttyp)
  1064.                 ELSIF f = LReal THEN Convert(x, OPT.realtyp)
  1065.                 ELSE err(111)
  1066.                 END
  1067.         | longfn: (*LONG*)
  1068.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1069.                 ELSIF f = SInt THEN Convert(x, OPT.inttyp)
  1070.                 ELSIF f = Int THEN Convert(x, OPT.linttyp)
  1071.                 ELSIF f = Real THEN Convert(x, OPT.lrltyp)
  1072.                 ELSIF f = Char THEN Convert(x, OPT.linttyp)
  1073.                 ELSE err(111)
  1074.                 END
  1075.         | incfn, decfn: (*INC, DEC*)
  1076.                 IF NotVar(x) THEN err(112)
  1077.                 ELSIF ~(f IN intSet) THEN err(111)
  1078.                 ELSIF x^.readonly THEN err(76)
  1079.                 END
  1080.         | inclfn, exclfn: (*INCL, EXCL*)
  1081.                 IF NotVar(x) THEN err(112)
  1082.                 ELSIF x^.typ # OPT.settyp THEN err(111); x^.typ := OPT.settyp
  1083.                 ELSIF x^.readonly THEN err(76)
  1084.                 END
  1085.         | lenfn: (*LEN*)
  1086.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1087.                 ELSIF ~(x^.typ^.comp IN {DynArr, Array}) THEN err(131)
  1088.                 END
  1089.         | copyfn: (*COPY*)
  1090.                 IF (x^.class = Nconst) & (f = Char) THEN CharToString(x); f := String END ;
  1091.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1092.                 ELSIF (~(x^.typ^.comp IN {DynArr, Array}) OR (x^.typ^.BaseTyp^.form # Char))
  1093.                      & (f # String) THEN err(111)
  1094.                 END
  1095.         | ashfn: (*ASH*)
  1096.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1097.                 ELSIF f IN intSet THEN
  1098.                     IF f # LInt THEN Convert(x, OPT.linttyp) END
  1099.                 ELSE err(111); x^.typ := OPT.linttyp
  1100.                 END
  1101.         | adrfn: (*SYSTEM.ADR*)
  1102.                 CheckLeaf(x, FALSE); MOp(adr, x)
  1103.         | sizefn: (*SIZE*)
  1104.                 IF x^.class # Ntype THEN err(110); x := NewIntConst(1)
  1105.                 ELSIF (f IN {Byte..Set, Pointer, ProcTyp}) OR (x^.typ^.comp IN {Array, Record}) THEN
  1106.                     typSize(x^.typ, FALSE); x := NewIntConst(x^.typ^.size)
  1107.                 ELSE err(111); x := NewIntConst(1)
  1108.                 END
  1109.         | ccfn: (*SYSTEM.CC*)
  1110.                 MOp(cc, x)
  1111.         | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
  1112.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1113.                 ELSIF ~(f IN intSet + {Byte, Char, Set}) THEN err(111)
  1114.                 END
  1115.         | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*)
  1116.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1117.                 ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp)
  1118.                 ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp
  1119.                 END
  1120.         | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*)
  1121.                 IF (f IN intSet) & (x^.class = Nconst) THEN
  1122.                     IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END
  1123.                 ELSE err(69)
  1124.                 END
  1125.         | callfn: (*SYSTEM.CALL*)        (*<<OJ*)
  1126.                 IF (f IN intSet) & (x^.class = Nconst) THEN
  1127.                     IF (x^.conval^.intval > -30) OR (x^.conval^.intval < MIN(INTEGER)) THEN err(220) END
  1128.                 ELSE err(69)
  1129.                 END
  1130.         | valfn: (*SYSTEM.VAL*)
  1131.                 IF x^.class # Ntype THEN err(110)
  1132.                 ELSIF (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(111)
  1133.                 END
  1134.         | sysnewfn: (*SYSTEM.NEW*)
  1135.                 IF NotVar(x) THEN err(112)
  1136.                 ELSIF f = Pointer THEN
  1137.                     IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END
  1138.                 ELSE err(111)
  1139.                 END
  1140.         | assertfn: (*ASSERT*)
  1141.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := NewBoolConst(FALSE)
  1142.                 ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE)
  1143.                 ELSE MOp(not, x)
  1144.                 END
  1145.         END ;
  1146.         par0 := x
  1147.     END StPar0;
  1148.     PROCEDURE StPar1*(VAR par0: OPT.Node; x: OPT.Node; fctno: SHORTINT);    (* x: second parameter of standard proc *)
  1149.         VAR f, L: INTEGER; typ: OPT.Struct; p, t: OPT.Node;
  1150.         PROCEDURE NewOp(class, subcl: SHORTINT; left, right: OPT.Node): OPT.Node;
  1151.             VAR node: OPT.Node;
  1152.         BEGIN
  1153.             node := OPT.NewNode(class); node^.subcl := subcl;
  1154.             node^.left := left; node^.right := right; RETURN node
  1155.         END NewOp;
  1156.     BEGIN p := par0; f := x^.typ^.form;
  1157.         CASE fctno OF
  1158.           incfn, decfn: (*INC DEC*)
  1159.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); p^.typ := OPT.notyp
  1160.                 ELSE
  1161.                     IF x^.typ # p^.typ THEN
  1162.                         IF (x^.class = Nconst) & (f IN intSet) THEN Convert(x, p^.typ)
  1163.                         ELSE err(111)
  1164.                         END
  1165.                     END ;
  1166.                     p := NewOp(Nassign, fctno, p, x);
  1167.                     p^.typ := OPT.notyp
  1168.                 END
  1169.         | inclfn, exclfn: (*INCL, EXCL*)
  1170.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1171.                 ELSIF f IN intSet THEN
  1172.                     IF (x^.class = Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202)
  1173.                     END ;
  1174.                     p := NewOp(Nassign, fctno, p, x)
  1175.                 ELSE err(111)
  1176.                 END ;
  1177.                 p^.typ := OPT.notyp
  1178.         | lenfn: (*LEN*)
  1179.                 IF ~(f IN intSet) OR (x^.class # Nconst) THEN err(69)
  1180.                 ELSIF f = SInt THEN
  1181.                     L := SHORT(x^.conval^.intval); typ := p^.typ;
  1182.                     WHILE (L > 0) & (typ^.comp IN {DynArr, Array}) DO typ := typ^.BaseTyp; DEC(L) END ;
  1183.                     IF (L # 0) OR ~(typ^.comp IN {DynArr, Array}) THEN err(132)
  1184.                     ELSE x^.obj := NIL;
  1185.                         IF typ^.comp = DynArr THEN
  1186.                             WHILE p^.class = Nindex DO p := p^.left; INC(x^.conval^.intval) END ;    (* possible side effect ignored *)
  1187.                             p := NewOp(Ndop, len, p, x); p^.typ := OPT.linttyp
  1188.                         ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p)
  1189.                         END
  1190.                     END
  1191.                 ELSE err(132)
  1192.                 END
  1193.         | copyfn: (*COPY*)
  1194.                 IF NotVar(x) THEN err(112)
  1195.                 ELSIF (x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form = Char) THEN
  1196.                     IF x^.readonly THEN err(76) END ;
  1197.                     t := x; x := p; p := t; p := NewOp(Nassign, copyfn, p, x)
  1198.                 ELSE err(111)
  1199.                 END ;
  1200.                 p^.typ := OPT.notyp
  1201.         | ashfn: (*ASH*)
  1202.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1203.                 ELSIF f IN intSet THEN
  1204.                     IF (p^.class = Nconst) & (x^.class = Nconst) THEN
  1205.                         IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1
  1206.                         ELSIF x^.conval^.intval >= 0 THEN
  1207.                             IF ABS(p^.conval^.intval) <= MAX(LONGINT) DIV ASH(1, x^.conval^.intval) THEN
  1208.                                 p^.conval^.intval := p^.conval^.intval * ASH(1, x^.conval^.intval)
  1209.                             ELSE err(208); p^.conval^.intval := 1
  1210.                             END
  1211.                         ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval)
  1212.                         END ;
  1213.                         p^.obj := NIL
  1214.                     ELSE p := NewOp(Ndop, ash, p, x); p^.typ := OPT.linttyp
  1215.                     END
  1216.                 ELSE err(111)
  1217.                 END
  1218.         | newfn: (*NEW(p, x...)*)
  1219.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1220.                 ELSIF p^.typ^.comp = DynArr THEN
  1221.                     IF f IN intSet THEN
  1222.                         IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END
  1223.                     ELSE err(111)
  1224.                     END ;
  1225.                     p^.right := x; p^.typ := p^.typ^.BaseTyp
  1226.                 ELSE err(64)
  1227.                 END
  1228.         | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
  1229.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1230.                 ELSIF ~(f IN intSet) THEN err(111)
  1231.                 ELSE
  1232.                     IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ;
  1233.                     p^.typ := p^.left^.typ
  1234.                 END
  1235.         | getfn, putfn, getrfn, putrfn, callfn: (*SYSTEM.GET, .PUT, .GETREG, .PUTREG, .CALL*)        (*<<OJ*)
  1236.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1237.                 ELSIF f IN {Undef..Set, Pointer, ProcTyp} THEN
  1238.                     IF (fctno = getfn) OR (fctno = getrfn) THEN
  1239.                         IF NotVar(x) THEN err(112) END ;
  1240.                         t := x; x := p; p := t
  1241.                     END ;
  1242.                     p := NewOp(Nassign, fctno, p, x)
  1243.                 ELSE err(111)
  1244.                 END ;
  1245.                 p^.typ := OPT.notyp
  1246.         | bitfn: (*SYSTEM.BIT*)
  1247.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1248.                 ELSIF f IN intSet THEN
  1249.                     p := NewOp(Ndop, bit, p, x)
  1250.                 ELSE err(111)
  1251.                 END ;
  1252.                 p^.typ := OPT.booltyp
  1253.         | valfn: (*SYSTEM.VAL*)    (* type is changed without considering the byte ordering on the target machine *)
  1254.                 IF (x^.class = Ntype) OR (x^.class = Nproc) OR
  1255.                     (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(126)
  1256.                 END ;
  1257.                 IF (x^.class >= Nconst) OR ((f IN realSet) # (p^.typ^.form IN realSet)) THEN
  1258.                     t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t
  1259.                 ELSE x^.readonly := FALSE
  1260.                 END ;
  1261.                 x^.typ := p^.typ; p := x
  1262.         | sysnewfn: (*SYSTEM.NEW*)
  1263.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1264.                 ELSIF f IN intSet THEN
  1265.                     p := NewOp(Nassign, sysnewfn, p, x)
  1266.                 ELSE err(111)
  1267.                 END ;
  1268.                 p^.typ := OPT.notyp
  1269.         | movefn: (*SYSTEM.MOVE*)
  1270.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1271.                 ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp)
  1272.                 ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp
  1273.                 END ;
  1274.                 p^.link := x
  1275.         | assertfn: (*ASSERT*)
  1276.                 IF (f IN intSet) & (x^.class = Nconst) THEN
  1277.                     IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN
  1278.                         BindNodes(Ntrap, OPT.notyp, x, x);
  1279.                         x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos;
  1280.                         Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos;
  1281.                         Construct(Nifelse, p, NIL); OptIf(p);
  1282.                         IF p = NIL THEN    (* ASSERT(TRUE) *)
  1283.                         ELSIF p^.class = Ntrap THEN err(99)
  1284.                         ELSE p^.subcl := assertfn
  1285.                         END
  1286.                     ELSE err(218)
  1287.                     END
  1288.                 ELSE err(69)
  1289.                 END
  1290.         ELSE err(64)
  1291.         END ;
  1292.         par0 := p
  1293.     END StPar1;
  1294.     PROCEDURE StParN*(VAR par0: OPT.Node; x: OPT.Node; fctno, n: INTEGER);    (* x: n+1-th param of standard proc *)
  1295.         VAR node: OPT.Node; f: INTEGER; p: OPT.Node;
  1296.     BEGIN p := par0; f := x^.typ^.form;
  1297.         IF fctno = newfn THEN (*NEW(p, ..., x...*)
  1298.             IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1299.             ELSIF p^.typ^.comp # DynArr THEN err(64)
  1300.             ELSIF f IN intSet THEN
  1301.                 IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ;
  1302.                 node := p^.right; WHILE node^.link # NIL DO node := node^.link END ;
  1303.                 node^.link := x; p^.typ := p^.typ^.BaseTyp
  1304.             ELSE err(111)
  1305.             END
  1306.         ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*)
  1307.             IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1308.             ELSIF f IN intSet THEN
  1309.                 node := OPT.NewNode(Nassign); node^.subcl := movefn; node^.right := p;
  1310.                 node^.left := p^.link; p^.link := x; p := node
  1311.             ELSE err(111)
  1312.             END ;
  1313.             p^.typ := OPT.notyp
  1314.         ELSE err(64)
  1315.         END ;
  1316.         par0 := p
  1317.     END StParN;
  1318.     PROCEDURE StFct*(VAR par0: OPT.Node; fctno: SHORTINT; parno: INTEGER);
  1319.         VAR dim: INTEGER; x, p: OPT.Node;
  1320.     BEGIN p := par0;
  1321.         IF fctno <= ashfn THEN
  1322.             IF (fctno = newfn) & (p^.typ # OPT.notyp) THEN
  1323.                 IF p^.typ^.comp = DynArr THEN err(65) END ;
  1324.                 p^.typ := OPT.notyp
  1325.             ELSIF fctno <= sizefn THEN (* 1 param *)
  1326.                 IF parno < 1 THEN err(65) END
  1327.             ELSE (* more than 1 param *)
  1328.                 IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*)
  1329.                     BindNodes(Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno; p^.right^.typ := p^.left^.typ
  1330.                 ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*)
  1331.                     IF p^.typ^.comp = DynArr THEN dim := 0;
  1332.                         WHILE p^.class = Nindex DO p := p^.left; INC(dim) END ;    (* possible side effect ignored *)
  1333.                         BindNodes(Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := len
  1334.                     ELSE
  1335.                         p := NewIntConst(p^.typ^.n)
  1336.                     END
  1337.                 ELSIF parno < 2 THEN err(65)
  1338.                 END
  1339.             END
  1340.         ELSIF fctno = assertfn THEN
  1341.             IF parno = 1 THEN x := NIL;
  1342.                 BindNodes(Ntrap, OPT.notyp, x, NewIntConst(AssertTrap));
  1343.                 x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos;
  1344.                 Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos;
  1345.                 Construct(Nifelse, p, NIL); OptIf(p);
  1346.                 IF p = NIL THEN    (* ASSERT(TRUE) *)
  1347.                 ELSIF p^.class = Ntrap THEN err(99)
  1348.                 ELSE p^.subcl := assertfn
  1349.                 END
  1350.             ELSIF parno < 1 THEN err(65)
  1351.             END
  1352.         ELSE (*SYSTEM*)
  1353.             IF (parno < 1) OR
  1354.                 (fctno > ccfn) & (parno < 2) OR
  1355.                 (fctno = movefn) & (parno < 3) THEN err(65)
  1356.             END
  1357.         END ;
  1358.         par0 := p
  1359.     END StFct;
  1360.     PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN);
  1361.         VAR f: INTEGER;
  1362.     BEGIN (* ftyp^.comp = DynArr *)
  1363.         f := atyp^.comp; ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp;
  1364.         IF fvarpar & (ftyp = OPT.bytetyp) THEN (* ok, but ... *)
  1365.             IF ~(f IN {Array, DynArr}) OR ~(atyp^.form IN {Byte..SInt}) THEN err(-301) END (* ... warning 301 *)
  1366.         ELSIF f IN {Array, DynArr} THEN
  1367.             IF ftyp^.comp = DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar)
  1368.             ELSIF ftyp # atyp THEN
  1369.                 IF ~fvarpar & (ftyp.form = Pointer) & (atyp.form = Pointer) THEN
  1370.                     ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp;
  1371.                     IF (ftyp^.comp = Record) & (atyp^.comp = Record) THEN
  1372.                         WHILE (ftyp # atyp) & (atyp # NIL) & (atyp # OPT.undftyp) DO atyp := atyp^.BaseTyp END ;
  1373.                         IF atyp = NIL THEN err(113) END
  1374.                     ELSE err(66)
  1375.                     END
  1376.                 ELSE err(66)
  1377.                 END
  1378.             END ;
  1379.         ELSE err(67)
  1380.         END
  1381.     END DynArrParCheck;
  1382.     PROCEDURE CheckReceiver(VAR x: OPT.Node; fp: OPT.Object);
  1383.     BEGIN
  1384.         IF fp^.typ^.form = Pointer THEN
  1385.             IF x^.class = Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = Record*) err(71) END
  1386.         END
  1387.     END CheckReceiver;
  1388.     PROCEDURE PrepCall*(VAR x: OPT.Node; VAR fpar: OPT.Object);
  1389.     BEGIN
  1390.         IF (x^.obj # NIL) & (x^.obj^.mode IN {LProc, XProc, TProc, CProc}) THEN
  1391.             fpar := x^.obj^.link;
  1392.             IF x^.obj^.mode = TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END
  1393.         ELSIF (x^.class # Ntype) & (x^.typ # NIL) & (x^.typ^.form = ProcTyp) THEN
  1394.             fpar := x^.typ^.link
  1395.         ELSE err(121); fpar := NIL; x^.typ := OPT.undftyp
  1396.         END
  1397.     END PrepCall;
  1398.     PROCEDURE Param*(ap: OPT.Node; fp: OPT.Object);
  1399.         VAR q: OPT.Struct;
  1400.     BEGIN
  1401.         IF fp.typ.form # Undef THEN
  1402.             IF fp^.mode = VarPar THEN
  1403.                 IF NotVar(ap) THEN err(122)
  1404.                 ELSE CheckLeaf(ap, FALSE)
  1405.                 END ;
  1406.                 IF ap^.readonly THEN err(76) END ;
  1407.                 IF fp^.typ^.comp = DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE)
  1408.                 ELSIF (fp^.typ^.comp = Record) & (ap^.typ^.comp = Record) THEN
  1409.                     q := ap^.typ;
  1410.                     WHILE (q # fp^.typ) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  1411.                     IF q = NIL THEN err(111) END
  1412.                 ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = Pointer) THEN (* ok *)
  1413.                 ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = Byte) & (ap^.typ^.form IN {Char, SInt})) THEN err(123)
  1414.                 END
  1415.             ELSIF fp^.typ^.comp = DynArr THEN
  1416.                 IF (ap^.class = Nconst) & (ap^.typ^.form = Char) THEN CharToString(ap) END ;
  1417.                 IF (ap^.typ^.form = String) & (fp^.typ^.BaseTyp^.form = Char) THEN (* ok *)
  1418.                 ELSIF ap^.class >= Nconst THEN err(59)
  1419.                 ELSE DynArrParCheck(fp^.typ, ap^.typ, FALSE)
  1420.                 END
  1421.             ELSE CheckAssign(fp^.typ, ap)
  1422.             END
  1423.         END
  1424.     END Param;
  1425.     PROCEDURE StaticLink*(dlev: SHORTINT);
  1426.         VAR scope: OPT.Object;
  1427.     BEGIN
  1428.         scope := OPT.topScope;
  1429.         WHILE dlev > 0 DO DEC(dlev);
  1430.             INCL(scope^.link^.conval^.setval, slNeeded);
  1431.             scope := scope^.left
  1432.         END
  1433.     END StaticLink;
  1434.     PROCEDURE Call*(VAR x: OPT.Node; apar: OPT.Node; fp: OPT.Object);
  1435.         VAR typ: OPT.Struct; p: OPT.Node; lev: SHORTINT;
  1436.     BEGIN
  1437.         IF x^.class = Nproc THEN typ := x^.typ;
  1438.             lev := x^.obj^.mnolev;
  1439.             IF lev > 0 THEN StaticLink(OPT.topScope^.mnolev-lev) END ;
  1440.             IF x^.obj^.mode = IProc THEN err(121) END
  1441.         ELSIF (x^.class = Nfield) & (x^.obj^.mode = TProc) THEN typ := x^.typ;
  1442.             x^.class := Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link
  1443.         ELSE typ := x^.typ^.BaseTyp
  1444.         END ;
  1445.         BindNodes(Ncall, typ, x, apar); x^.obj := fp
  1446.     END Call;
  1447.     PROCEDURE Enter*(VAR procdec: OPT.Node; stat: OPT.Node; proc: OPT.Object);
  1448.         VAR x: OPT.Node;
  1449.     BEGIN
  1450.         x := OPT.NewNode(Nenter); x^.typ := OPT.notyp; x^.obj := proc;
  1451.         x^.left := procdec; x^.right := stat; procdec := x
  1452.     END Enter;
  1453.     PROCEDURE Return*(VAR x: OPT.Node; proc: OPT.Object);
  1454.         VAR node: OPT.Node;
  1455.     BEGIN
  1456.         IF proc = NIL THEN (* return from module *)
  1457.             IF x # NIL THEN err(124) END
  1458.         ELSE
  1459.             IF x # NIL THEN CheckAssign(proc^.typ, x)
  1460.             ELSIF proc^.typ # OPT.notyp THEN err(124)
  1461.             END
  1462.         END ;
  1463.         node := OPT.NewNode(Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node
  1464.     END Return;
  1465.     PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node);
  1466.         VAR z: OPT.Node;
  1467.     BEGIN
  1468.         IF x^.class >= Nconst THEN err(56) END ;
  1469.         CheckAssign(x^.typ, y);
  1470.         IF x^.readonly THEN err(76) END ;
  1471.         IF x^.typ^.comp = Record THEN
  1472.             IF x^.class = Nguard THEN z := x^.left ELSE z := x END ;
  1473.             IF (z^.class = Nderef) & (z^.left^.class = Nguard) THEN
  1474.                 z^.left := z^.left^.left    (* skip guard before dereferencing *)
  1475.             END ;
  1476.             IF (x^.typ^.strobj # NIL) & ((z^.class = Nderef) OR (z^.class = Nvarpar)) THEN
  1477.                 BindNodes(Neguard, x^.typ, z, NIL); x := z
  1478.             END
  1479.         ELSIF (x^.typ^.comp = Array) & (x^.typ^.BaseTyp = OPT.chartyp) &
  1480.                 (y^.typ^.form = String) & (y^.conval^.intval2 = 1) THEN    (* replace array := "" with array[0] := 0X *)
  1481.             y^.typ := OPT.chartyp; y^.conval^.intval := 0;
  1482.             Index(x, NewIntConst(0))
  1483.         END ;
  1484.         BindNodes(Nassign, OPT.notyp, x, y); x^.subcl := assign
  1485.     END Assign;
  1486.     PROCEDURE Inittd*(VAR inittd, last: OPT.Node; typ: OPT.Struct);
  1487.         VAR node: OPT.Node;
  1488.     BEGIN
  1489.         node := OPT.NewNode(Ninittd); node^.typ := typ;
  1490.         node^.conval := OPT.NewConst(); node^.conval^.intval := typ^.txtpos;
  1491.         IF inittd = NIL THEN inittd := node ELSE last^.link := node END ;
  1492.         last := node
  1493.     END Inittd;
  1494. BEGIN
  1495.     maxExp := log(MAX(LONGINT) DIV 2 + 1); maxExp := exp
  1496. END OPB.
  1497.